Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/lisp/clx.lha/clx/clx.l

Text File | 1988-09-12 | 31KB | 944 lines

;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-

;; Version 4

;;;
;;;             TEXAS INSTRUMENTS INCORPORATED
;;;                  P.O. BOX 2909
;;;                   AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;

;; Primary Interface Author:
;;    Robert W. Scheifler
;;    MIT Laboratory for Computer Science
;;    545 Technology Square, Room 418
;;    Cambridge, MA 02139
;;    [e-mail]

;; Design Contributors:
;;    Dan Cerys, Texas Instruments
;;    Scott Fahlman, CMU
;;    Kerry Kimbrough, Texas Instruments
;;    Chris Lindblad, MIT
;;    Rob MacLachlan, CMU
;;    Mike McMahon, Symbolics
;;    David Moon, Symbolics
;;    LaMott Oren, Texas Instruments
;;    Daniel Weinreb, Symbolics
;;    John Wroclawski, MIT
;;    Richard Zippel, Symbolics

;; Primary Implementation Author:
;;    LaMott Oren, Texas Instruments

;; Implementation Contributors:
;;    Chris Lindblad, MIT
;;    Robert Scheifler, MIT

;;;
;;; Change history:
;;;
;;;  Date    Author        Description
;;; -------------------------------------------------------------------------------------
;;; 04/07/87    R.Scheifler    Created code stubs
;;; 04/08/87    L.Oren        Started Implementation
;;; 05/11/87    L.Oren        Included draft 3 revisions
;;; 07/07/87    L.Oren        Untested alpha release to MIT
;;; 07/17/87    L.Oren        Alpha release
;;; 08/**/87    C.Lindblad    Rewrite of buffer code
;;; 08/**/87    et al        Various random bug fixes
;;; 08/**/87    R.Scheifler    General syntactic and portability cleanups
;;; 08/**/87    R.Scheifler    Rewrite of gcontext caching and shadowing
;;; 09/02/87    L.Oren        Change events from resource-ids to objects
;;; 12/24/87    R.Budzianowski    KCL support
;;; 12/**/87    J.Irwin        ExCL 2.0 support
;;; 01/20/88    L.Oren        Add server extension mechanisms
;;; 01/20/88    L.Oren        Only force output when blocking on input
;;; 01/20/88    L.Oren        Uniform support for :event-window on events
;;; 01/28/88    L.Oren        Add window manager property functions
;;; 01/28/88    L.Oren        Add character translation facility
;;; 02/**/87    J.Irwin        Allegro 2.2 support

;;; This is considered a somewhat changeable interface.  Discussion of better
;;; integration with CLOS, support for user-specified subclassess of basic
;;; objects, and the additional functionality to match the C Xlib is still in
;;; progress.  Bug reports should be addressed to [e-mail].

;; Note: all of the following is in the package XLIB.

(in-package 'xlib :use '(lisp))

(pushnew :xlib *features*)

(export '(
      card32
      card29
      int32
      card16
      int16
      card8
      int8
      rgb-val
      angle
      mask32
      mask16
      array-index
      pixel
      image-depth
      display
      display-p
      display-display
      display-after-function
      display-protocol-major-version
      display-protocol-minor-version
      display-vendor-name
      display-resource-id-base
      display-resource-id-mask
      display-xid
      display-byte-order
      display-version-number
      display-release-number
      display-max-request-length
      display-squish
      display-default-screen
      display-nscreens
      display-roots
      display-motion-buffer-size
      display-xdefaults
      display-image-lsb-first-p
      display-bitmap-format
      display-pixmap-formats
      display-min-keycode
      display-max-keycode
      display-error-handler
      display-authorization-name
      display-authorization-data
      display-plist
      color
      color-p
      color-red
      color-green
      color-blue
      make-color
      color-rgb
      resource-id
      drawable
      drawable-p
      drawable-equal
      drawable-id
      drawable-display
      drawable-plist
      window
      window-p
      window-equal
      window-id
      window-display
      window-plist
      pixmap
      pixmap-p
      pixmap-equal
      pixmap-id
      pixmap-display
      pixmap-plist
      colormap
      colormap-p
      colormap-equal
      colormap-id
      colormap-display
      cursor
      cursor-p
      cursor-equal
      cursor-id
      cursor-display
      xatom
      stringable
      fontable
      timestamp
      bit-gravity
      win-gravity
      grab-status
      boolean
      alist
      repeat-seq
      point-seq
      seg-seq
      rect-seq
      arc-seq
      gcontext
      gcontext-p
      gcontext-equal
      gcontext-id
      gcontext-display
      gcontext-plist
      event-mask-class
      event-mask
      pointer-event-mask-class
      pointer-event-mask
      device-event-mask-class
      device-event-mask
      modifier-key
      modifier-mask
      state-mask-key
      gcontext-key
      event-key
      error-key
      draw-direction
      boole-constant
      bitmap-format
      bitmap-format-p
      bitmap-format-unit
      bitmap-format-pad
      bitmap-format-lsb-first-p
      pixmap-format
      pixmap-format-p
      pixmap-format-depth
      pixmap-format-bits-per-pixel
      pixmap-format-scanline-pad
      visual-info
      visual-info-p
      visual-info-id
      visual-info-class
      visual-info-red-mask
      visual-info-green-mask
      visual-info-blue-mask
      visual-info-bits-per-rgb
      visual-info-colormap-entries
      visual-info-plist
      screen
      screen-p
      screen-root
      screen-width
      screen-height
      screen-width-in-millimeters
      screen-height-in-millimeters
      screen-depths
      screen-root-depth
      screen-root-visual
      screen-default-colormap
      screen-white-pixel
      screen-black-pixel
      screen-min-installed-maps
      screen-max-installed-maps
      screen-backing-stores
      screen-save-unders-p
      screen-event-mask-at-open
      screen-plist
      font
      font-p
      font-equal
      font-id
      font-display
      font-name
      font-direction
      font-min-char
      font-max-char
      font-min-byte1
      font-max-byte1
      font-min-byte2
      font-max-byte2
      font-all-chars-exist-p
      font-default-char
      font-min-bounds
      font-max-bounds
      font-ascent
      font-descent
      font-properties
      font-property
      font-plist
      char-left-bearing
      max-char-left-bearing
      min-char-left-bearing
      char-right-bearing
      max-char-right-bearing
      min-char-right-bearing
      char-width
      max-char-width
      min-char-width
      char-ascent
      max-char-ascent
      min-char-ascent
      char-descent
      max-char-descent
      min-char-descent
      char-attributes
      max-char-attributes
      min-char-attributes
      make-event-mask
      make-event-keys
      make-state-mask
      make-state-keys
      ))

(defparameter *protocol-major-version* 11.)
(defparameter *protocol-minor-version* 0)

(defparameter *x-tcp-port* 6000) ;; add display number

; Note: various perversions of the CL type system are used below.
; Examples: (list elt-type) (sequence elt-type)

;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
;; the relationships should be fairly obvious.  We have no intention of writing yet
;; another moby document for this interface.

;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color.
;; These types are defined solely by a functional interface; we do not specify
;; whether they are implemented as structures or flavors or ...  Although functions
;; below are written using DEFUN, this is not an implementation requirement (although
;; it is a requirement that they be functions as opposed to macros or special forms).
;; It is unclear whether with-slots in the Common Lisp Object System must work on
;; them.

;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as
;; compound objects, rather than as integer resource-ids.  This allows applications
;; to deal with multiple displays without having an explicit display argument in the
;; most common functions.  Every function uses the display object indicated by the
;; first argument that is or contains a display; it is an error if arguments contain
;; different displays, and predictable results are not guaranteed.

;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following
;; five functions:

;(defun make-<mumble> (display resource-id)
;  ;; This function should almost never be called by applications, except in handling
;  ;; events.  To minimize consing in some implementations, this may use a cache in
;  ;; the display.  Make-gcontext creates with :cache-p nil.  Make-font creates with
;  ;; cache-p true.
;  (declare (type display display)
;       (type integer resource-id)
;       (values <mumble>)))

;(defun <mumble>-display (<mumble>)
;  (declare (type <mumble> <mumble>)
;       (values display)))

;(defun <mumble>-id (<mumble>)
;  (declare (type <mumble> <mumble>)
;       (values integer)))

;(defun <mumble>-equal (<mumble>-1 <mumble>-2)
;  (declare (type <mumble> <mumble>-1 <mumble>-2)))

;(defun <mumble>-p (<mumble>-1 <mumble>-2)
;  (declare (type <mumble> <mumble>-1 <mumble>-2)
;       (values boolean)))

(deftype boolean () '(or null (not null)))

(deftype card32 () '(unsigned-byte 32))

(deftype card29 () '(unsigned-byte 29))

(deftype int32 () '(signed-byte 32))

(deftype card16 () '(unsigned-byte 16))

(deftype int16 () '(signed-byte 16))

(deftype card8 () '(unsigned-byte 8))

(deftype int8 () '(signed-byte 8))

; Note that we are explicitly using a different rgb representation than what
; is actually transmitted in the protocol.

(deftype rgb-val () '(float 0.0 1.0))

; Note that we are explicitly using a different angle representation than what
; is actually transmitted in the protocol.

(deftype angle () 'number)

(deftype mask32 () 'card32)

(deftype mask16 () 'card16)

(deftype pixel () '(unsigned-byte 32))
(deftype image-depth () '(integer 0 32))

(deftype resource-id () 'card29)

(deftype keysym () 'card32)

; The following functions are provided by color objects:

; The intention is that IHS and YIQ and CYM interfaces will also exist.
; Note that we are explicitly using a different spectrum representation
; than what is actually transmitted in the protocol.

(defstruct (color (:constructor make-color-internal (red green blue)))
  (red 0.0 :type rgb-val)
  (green 0.0 :type rgb-val)
  (blue 0.0 :type rgb-val))

(defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys)
  (declare (type rgb-val red green blue))
  (declare-values color)
  (make-color-internal red green blue))

(defun color-rgb (color)
  (declare (type color color))
  (declare-values red green blue)
  (values (color-red color) (color-green color) (color-blue color)))

(defstruct bitmap-format
  (unit 8 :type (member 8 16 32))
  (pad 8 :type (member 8 16 32))
  (lsb-first-p nil :type boolean))

(defstruct pixmap-format
  (depth 0 :type image-depth)
  (bits-per-pixel 8 :type (member 1 4 8 16 24 32))
  (scanline-pad 8 :type (member 8 16 32)))

(defparameter *atom-cache-size* 200)
(defparameter *resource-id-map-size* 500)

(defstruct (display (:include buffer)
            (:constructor make-display-internal)
            (:print-function display-print))
  host                        ; Server Host
  (display 0 :type integer)            ; Display number on host
  (after-function nil)                ; Function to call after every request
  (waiting-reply-p nil)                ; non-nil when waiting for a reply
  (input-lock (make-process-lock))        ; Lock over reading from the input stream
  (event-lock (make-process-lock))        ; with-event-queue lock
  (event-queue-lock (make-process-lock))    ; new-events/event-queue lock
  (new-events nil :type list)            ; unprocessed events (a cons of event-queue)
  (event-queue (list nil) :type cons)        ; processed and unprocessed events
  (atom-cache (make-hash-table :test #'eq :size *atom-cache-size*)
          :type hash-table)            ; EQ Hash table relating atoms keywords
                        ; to resource id's
  (font-cache nil)                ;list of font
  (protocol-major-version 0 :type card16)    ; Major version of server's X protocol
  (protocol-minor-version 0 :type card16)    ; minor version of servers X protocol
  (vendor-name "" :type string)            ; vendor of the server hardware
  (resource-id-base 0 :type resource-id)    ; resouce ID base
  (resource-id-mask 0 :type resource-id)    ; resource ID mask bits
  (resource-id-byte nil)            ; resource ID mask field (used with DPB & LDB)
  (resource-id-count 0 :type resource-id)    ; resource ID mask count
                        ; (used for allocating ID's)
  (resource-id-map (make-hash-table :test (resource-id-map-test)
                    :size *resource-id-map-size*)
           :type hash-table)        ; hash table maps resource-id's to
                        ; objects (used in lookup functions)
  (xid 'resourcealloc)                ; allocator function
  (byte-order :lsbfirst)            ; screen byte order, LSBFirst, MSBFirst
  (version-number 11 :type card16)        ; X protocol version number.
  (release-number 0 :type card32)        ; release of the server
  (max-request-length 0 :type card16)        ; maximum number 32 bit words in request
  (squish nil :type boolean)            ; Squish MouseMoved events?
  (default-screen)                ; default screen for operations
  (nscreens 1 :type card8)            ; number of screens on this server
  (roots nil :type list)            ; List of screens
  (motion-buffer-size 0 :type card32)        ; size of motion buffer
  (xdefaults)                    ; contents of defaults from server
  (image-lsb-first-p nil :type boolean)
  (bitmap-format (make-bitmap-format)        ; Screen image info
         :type bitmap-format)
  (pixmap-formats nil :type sequence)        ; list of pixmap formats
  (min-keycode 0 :type card8)            ; minimum key-code
  (max-keycode 0 :type card8)            ; maximum key-code
  (error-handler 'default-error-handler)    ; Error handler function
  (close-down-mode :destroy)              ; Close down mode saved by Set-Close-Down-Mode
  (authorization-name "" :type string)
  (authorization-data "" :type string)
  (last-width nil :type (or null card29))    ; Accumulated width of last string
  (keysym-mapping nil                ; Keysym mapping cached from server
          :type (or null (array * (* *))))
  (modifier-mapping nil :type list)        ; ALIST of (keysym . state-mask) for all modifier keysyms
  (keysym-translation nil :type list)        ; An alist of (keysym object function)
                        ; for display-local keysyms
  (extension-alist nil :type list)        ; extension alist, which has elements:
                        ; (name major-opcode first-event first-error)
  (event-extensions '#() :type vector)        ; Vector mapping X event-codes to event keys
  (performance-info)                ; Hook for gathering performance info
  (trace-history)                ; Hook for debug trace
  (plist)                    ; hook for extension to hang data
  )

;;(deftype drawable () '(or window pixmap))

(defstruct drawable
  (id 0 :type resource-id)
  (display nil :type (or null display))
  (plist nil :type list)            ; Extension hook
  )

(defstruct (window (:include drawable))
  )

(defstruct (pixmap (:include drawable))
  )

(defstruct colormap
  (id 0 :type resource-id)
  (display nil :type (or null display))
  )

(defstruct cursor
  (id 0 :type resource-id)
  (display nil :type (or null display))
  )

; Atoms are accepted as strings or symbols, and are always returned as keywords.
; Protocol-level integer atom ids are hidden, using a cache in the display object.

(deftype xatom () '(or string symbol))

(defconstant *predefined-atoms*
         '#(nil :primary :secondary :arc :atom :bitmap
            :cardinal :colormap :cursor
            :cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
            :cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7
            :drawable :font :integer :pixmap :point :rectangle
            :resource_manager :rgb_color_map :rgb_best_map
            :rgb_blue_map :rgb_default_map
            :rgb_gray_map :rgb_green_map :rgb_red_map :string
            :visualid :window :wm_command :wm_hints
            :wm_client_machine :wm_icon_name :wm_icon_size
            :wm_name :wm_normal_hints :wm_size_hints
            :wm_zoom_hints :min_space :norm_space :max_space
            :end_space :superscript_x :superscript_y
            :subscript_x :subscript_y
            :underline_position :underline_thickness
            :strikeout_ascent :strikeout_descent
            :italic_angle :x_height :quad_width :weight
            :point_size :resolution :copyright :notice
            :font_name :family_name :full_name :cap_height
            :wm_class :wm_transient_for))

(deftype stringable () '(or string symbol))

(deftype fontable () '(or stringable font))

; Nil stands for CurrentTime.

(deftype timestamp () '(or null card32))

(defconstant *bit-gravity-vector*
         '#(:forget :north-west :north :north-east :west
        :center :east :south-west :south
        :south-east :static))

(deftype bit-gravity ()
  '(member :forget :north-west :north :north-east :west
       :center :east :south-west :south :south-east :static))

(defconstant *win-gravity-vector*
         '#(:unmap :north-west :north :north-east :west
        :center :east :south-west :south :south-east
        :static))

(deftype win-gravity ()
  '(member :unmap :north-west :north :north-east :west
       :center :east :south-west :south :south-east :static))

(deftype grab-status ()
  '(member :success :already-grabbed :invalid-time :not-viewable))

; An association list.

(deftype alist (key-type-and-name datum-type-and-name)
  key-type-and-name datum-type-and-name 'list)

; A sequence, containing zero or more repetitions of the given elements,
; with the elements expressed as (type name).

(deftype repeat-seq (&rest elts) elts 'sequence)

(deftype point-seq () '(repeat-seq (int16 x) (int16 y)))

(deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))

(deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))

(deftype arc-seq ()
  '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
           (angle angle1) (angle angle2)))

(deftype gcontext-state () 'simple-vector)

(defstruct (gcontext (:copier nil))
  ;; The accessors convert to CLX data types.
  (id 0 :type resource-id)
  (display nil :type (or null display))
  (drawable nil :type (or null drawable))
  (cache-p t :type boolean)
  (server-state (allocate-gcontext-state) :type gcontext-state)
  (local-state (allocate-gcontext-state) :type gcontext-state)
  (plist nil :type list)            ; Extension hook
  )

(defconstant *event-mask-vector*
         '#(:key-press :key-release :button-press :button-release
        :enter-window :leave-window :pointer-motion :pointer-motion-hint
        :button-1-motion :button-2-motion :button-3-motion :button-4-motion
        :button-5-motion :button-motion :keymap-state :exposure :visibility-change
        :structure-notify :resize-redirect :substructure-notify :substructure-redirect
        :focus-change :property-change :colormap-change :owner-grab-button))

(deftype event-mask-class ()
  '(member :key-press :key-release :owner-grab-button :button-press :button-release
       :enter-window :leave-window :pointer-motion :pointer-motion-hint
       :button-1-motion :button-2-motion :button-3-motion :button-4-motion
       :button-5-motion :button-motion :exposure :visibility-change
       :structure-notify :resize-redirect :substructure-notify :substructure-redirect
       :focus-change :property-change :colormap-change :keymap-state))

(deftype event-mask ()
  '(or mask32 list)) ;; (OR integer (LIST event-mask-class))

(defconstant *pointer-event-mask-vector*
         '#(%error %error :button-press :button-release
        :enter-window :leave-window :pointer-motion :pointer-motion-hint
        :button-1-motion :button-2-motion :button-3-motion :button-4-motion
        :button-5-motion :button-motion :keymap-state))

(deftype pointer-event-mask-class ()
  '(member :button-press :button-release
       :enter-window :leave-window :pointer-motion :pointer-motion-hint
       :button-1-motion :button-2-motion :button-3-motion :button-4-motion
       :button-5-motion :button-motion :keymap-state))

(deftype pointer-event-mask ()
  '(or mask32 list)) ;;  '(or integer (list pointer-event-mask-class)))

(defconstant *device-event-mask-vector*
         '#(:key-press :key-release :button-press :button-release :pointer-motion
        :button-1-motion :button-2-motion :button-3-motion :button-4-motion
        :button-5-motion :button-motion))

(deftype device-event-mask-class ()
  '(member :key-press :key-release :button-press :button-release :pointer-motion
       :button-1-motion :button-2-motion :button-3-motion :button-4-motion
       :button-5-motion :button-motion))

(deftype device-event-mask ()
  '(or mask32 list)) ;;  '(or integer (list device-event-mask-class)))

(defconstant *state-mask-vector*
         '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
        :button-1 :button-2 :button-3 :button-4 :button-5))

(deftype modifier-key ()
  '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))

(deftype modifier-mask ()
  '(or (member :any) mask16 list)) ;;  '(or (member :any) integer (list modifier-key)))

(deftype state-mask-key ()
  '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))

(defconstant *gcontext-components*
         '(:function :plane-mask :foreground :background
           :line-width :line-style :cap-style :join-style :fill-style
           :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
           :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
           :arc-mode))

(deftype gcontext-key ()
  '(member :function :plane-mask :foreground :background
       :line-width :line-style :cap-style :join-style :fill-style
       :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
       :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
       :arc-mode))

(deftype event-key ()
  '(member :key-press :key-release :button-press :button-release :motion-notify
       :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
       :exposure :graphics-exposure :no-exposure :visibility-notify
       :create-notify :destroy-notify :unmap-notify :map-notify :map-request
       :reparent-notify :configure-notify :gravity-notify :resize-request
       :configure-request :circulate-notify :circulate-request :property-notify
       :selection-clear :selection-request :selection-notify
       :colormap-notify :client-message :mapping-notify))

(deftype error-key ()
  '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
       :illegal-request :implementation :length :match :name :pixmap :value :window))

(deftype draw-direction ()
  '(member :left-to-right :right-to-left))

(defconstant *boole-vector*
         '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1
        #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior
        #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
        #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))

(deftype boole-constant ()
  `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
       ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior
       ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2
       ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set))

(defstruct visual-info
  (id 0 :type card29)
  (class :static-gray :type (member :static-gray :static-color :true-color
                    :gray-scale :pseudo-color :direct-color))
  (red-mask 0 :type pixel)
  (green-mask 0 :type pixel)
  (blue-mask 0 :type pixel)
  (bits-per-rgb 1 :type card8)
  (colormap-entries 0 :type card16)
  (plist nil :type list)            ; Extension hook
  )

(defstruct screen
  (root nil :type (or null window))
  (width 0 :type card16)
  (height 0 :type card16)
  (width-in-millimeters 0 :type card16)
  (height-in-millimeters 0 :type card16)
  (depths nil :type (alist (image-depth depth) ((list visual-info) visuals)))
  (root-depth 1 :type image-depth)
  (root-visual 0 :type card29)
  (default-colormap nil :type (or null colormap))
  (white-pixel 0 :type pixel)
  (black-pixel 1 :type pixel)
  (min-installed-maps 1 :type card16)
  (max-installed-maps 1 :type card16)
  (backing-stores :never :type (member :never :when-mapped :always))
  (save-unders-p nil :type boolean)
  (event-mask-at-open 0 :type mask32)
  (plist nil :type list)            ; Extension hook
  )

;; The list contains alternating keywords and integers.
(deftype font-props () 'list)

(defstruct font-info
  (direction :left-to-right :type draw-direction)
  (min-char 0 :type card16)   ;; First character in font
  (max-char 0 :type card16)   ;; Last character in font
  (min-byte1 0 :type card8)   ;; The following are for 16 bit fonts
  (max-byte1 0 :type card8)   ;; and specify min&max values for
  (min-byte2 0 :type card8)   ;; the two character bytes
  (max-byte2 0 :type card8)
  (all-chars-exist-p nil :type boolean)
  (default-char 0 :type card16)
  (min-bounds nil :type (or null vector))
  (max-bounds nil :type (or null vector))
  (ascent 0 :type int16)
  (descent 0 :type int16)
  (properties nil :type font-props))

(defstruct (font (:constructor make-font-internal))
  (id-internal nil :type (or null resource-id)) ;; NIL when not opened
  (display nil :type (or null display))
  (reference-count 0 :type fixnum)
  (name "" :type (or null string)) ;; NIL when ID is for a GContext
  (font-info-internal nil :type (or null font-info))
  (char-infos-internal nil :type (or null vector))
  (local-only-p t :type boolean) ;; When T, always calculate text extents locally
  (plist nil :type list)            ; Extension hook
  )

(proclaim '(inline font-id font-font-info font-char-infos make-font))

(defun font-id (font)
  ;; Get font-id, opening font if needed
  (or (font-id-internal font)
      (open-font-internal font)))

(defun font-font-info (font)
  (or (font-font-info-internal font)
      (query-font font)))

(defun font-char-infos (font)
  (or (font-char-infos-internal font)
      (progn (query-font font)
         (font-char-infos-internal font))))

(defun make-font (&key id
          display
          (reference-count 0)
          (name "")
          (local-only-p t)
          font-info-internal)
  (make-font-internal :id-internal id
              :display display
              :reference-count reference-count
              :name name
              :local-only-p local-only-p
              :font-info-internal font-info-internal))

; For each component (<name> <unspec> :type <type>) of font-info,
; there is a corresponding function:

;(defun font-<name> (font)
;  (declare (type font font)
;       (values <type>)))

(eval-when (eval compile) ;; I'd rather use macrolet, but Symbolics doesn't like it...

(defmacro make-font-info-accessors (useless-name &body fields)
  `(within-definition (,useless-name make-font-info-accessors)
     ,@(mapcan
     #'(lambda (field)
         (let* ((type (second field))
            (n (string (first field)))
            (name (xintern 'font- n))
            (accessor (xintern 'font-info- n)))
           `((proclaim '(inline ,name))
         (defun ,name (font)
           (declare (type font font))
           (declare-values ,type)
           (,accessor (font-font-info font))))))
     fields)))

) ;; End eval-when

(make-font-info-accessors ignore
  (direction draw-direction)
  (min-char card16)
  (max-char card16)
  (min-byte1 card8)
  (max-byte1 card8)
  (min-byte2 card8)
  (max-byte2 card8)
  (all-chars-exist-p boolean)
  (default-char card16)
  (min-bounds vector)
  (max-bounds vector)
  (ascent int16)
  (descent int16)
  (properties font-props))

(defun font-property (font name)
  (declare (type font font)
       (type keyword name))
  (declare-values (or null int32))
  (getf (font-properties font) name))

(eval-when (eval compile) ;; I'd rather use macrolet, but Symbolics doesn't like it...

(defmacro make-mumble-equal (type)
  ;; When cached, EQ works fine, otherwise test resource id's and displays
  (let ((predicate (xintern type '-equal))
    (id (xintern type '-id))
    (dpy (xintern type '-display)))
    (if (member type *clx-cached-types*)
    `(within-definition (,type make-mumble-equal)
       (proclaim '(inline ,predicate))
       (defun ,predicate (a b) (eq a b)))
      `(within-definition (,type make-mumble-equal)
     (defun ,predicate (a b)
       (declare (type ,type a b))
       (and (= (,id a) (,id b))
        (eq (,dpy a) (,dpy b))))))))

) ;; End eval-when

(make-mumble-equal window)
(make-mumble-equal pixmap)
(make-mumble-equal cursor)
(make-mumble-equal font)
(make-mumble-equal gcontext)
(make-mumble-equal colormap)
(make-mumble-equal drawable)

;;;
;;; Event-mask encode/decode functions
;;;    Converts from keyword-lists to integer and back
;;;
(defun encode-mask (key-vector key-list key-type)
  ;; KEY-VECTOR is a vector containg bit-position keywords.  The position of the
  ;; keyword in the vector indicates its bit position in the resulting mask
  ;; KEY-LIST is either a mask or a list of KEY-TYPE
  ;; Returns NIL when KEY-LIST is not a list or mask.
  (declare (type vector key-vector)
       (type (or mask32 list) key-list))
  (declare-values (or mask32 nil))
  (typecase key-list
    (mask32 key-list)
    (list (let ((mask 0))
        (dolist (key key-list mask)
          (let ((bit (position key (the vector key-vector) :test #'eq)))
        (unless bit
          (x-type-error key key-type))
        (setq mask (logior mask (ash 1 bit)))))))))

(defun decode-mask (key-vector mask)
  (declare (type (simple-array keyword (*)) key-vector)
       (type mask32 mask))
  (declare-values list)
  (do ((m mask (ash m -1))
       (bit 0 (1+ bit))
       (len (length key-vector))
       (result nil))
      ((or (zerop m) (>= bit len)) result)
    (declare (type mask32 m)
         (fixnum bit len)
         (list result))
    (when (oddp m)
      (push (aref key-vector bit) result))))

(defun encode-event-mask (event-mask)
  (declare (type event-mask event-mask))
  (declare-values mask32)
  (or (encode-mask *event-mask-vector* event-mask 'event-mask-class)
      (x-type-error event-mask 'event-mask)))

(defun make-event-mask (&rest keys)
  ;; This is only defined for core events.
  ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
  (declare (type list keys)) ;; (list event-mask-class)
  (declare-values mask32)
  (encode-mask *event-mask-vector* keys 'event-mask-class))

(defun make-event-keys (event-mask)
  ;; This is only defined for core events.
  (declare (type mask32 event-mask))
  (declare-values (list event-mask-class))
  (decode-mask *event-mask-vector* event-mask))

(defun encode-device-event-mask (device-event-mask)
  (declare (type device-event-mask device-event-mask))
  (declare-values mask32)
  (or (encode-mask *device-event-mask-vector* device-event-mask
           'device-event-mask-class)
      (x-type-error device-event-mask 'device-event-mask)))

(defun encode-modifier-mask (modifier-mask)
  (declare (type modifier-mask modifier-mask)) ;; (list state-mask-key)
  (declare-values mask16)
  (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key)
      (and (eq modifier-mask :any) #x8000)
      (x-type-error modifier-mask 'modifier-mask)))

(defun encode-state-mask (state-mask)
  (declare (type (or mask16 list) state-mask)) ;; (list state-mask-key)
  (declare-values mask16)
  (or (encode-mask *state-mask-vector* state-mask 'state-mask-key)
      (x-type-error state-mask '(or mask16 (list state-mask-key)))))

(defun make-state-mask (&rest keys)
  ;; Useful for constructing modifier-mask, state-mask.
  (declare (type list keys)) ;; (list state-mask-key)
  (declare-values mask16)
  (encode-mask *state-mask-vector* keys 'state-mask-key))

(defun make-state-keys (state-mask)
  (declare (type mask16 state-mask))
  (declare-values (list state-mask-key))
  (decode-mask *state-mask-vector* state-mask))

(defun encode-pointer-event-mask (pointer-event-mask)
  (declare (type pointer-event-mask pointer-event-mask))
  (declare-values mask32)
  (or (encode-mask *pointer-event-mask-vector* pointer-event-mask
           'pointer-event-mask-class)
      (x-type-error pointer-event-mask 'pointer-event-mask)))